home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
PASWIZ20
/
MUSIC.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-11-04
|
7KB
|
295 lines
{ +----------------------------------------------------------------------+
| |
| PasWiz Copyright (c) 1990-1994 Thomas G. Hanlin III |
| |
+----------------------------------------------------------------------+
Music:
This unit provides a music interpreter that works like BASIC's PLAY
statement. Currently, only foreground music is supported. See the
PASWIZ.DOC manual for information about the command set.
}
UNIT Music;
INTERFACE
PROCEDURE PlayMF (Sounds: String);
PROCEDURE ResetMF;
{ --------------------------------------------------------------------------- }
IMPLEMENTATION
USES
CRT;
{$F+}
FUNCTION UpperCase (St: String): String; external;
FUNCTION WVal (St: String): Word; external;
{$L UPCASE.OBJ}
{$L WVAL.OBJ}
VAR
Octave, NoteLen, Tempo, SoundLen, TmpNoteLen: Integer;
BaseOctave: Array[0..11] of Integer;
BaseTime: LongInt;
Nr: Integer;
Error: Boolean;
NoteConvert: String;
{ grab a number from the music string }
PROCEDURE GetNum (VAR St: String; VAR Nr: Integer; VAR Error: Boolean);
VAR
Acc: String;
BEGIN
Acc := '';
WHILE (Length(St) > 0) AND (Pos(St[1], '0123456789') > 0) DO BEGIN
Acc := Acc + St[1];
Delete(St, 1, 1);
END;
IF (Length(Acc) = 0) OR (Length(Acc) > 3) THEN
Error := TRUE
ELSE BEGIN
Error := FALSE;
Nr := WVal(Acc);
END;
END;
{ play a note }
PROCEDURE PlayNote (Freq: Word);
VAR
Time: Word;
BEGIN
IF TmpNoteLen = 0 THEN
TmpNoteLen := NoteLen;
Time := BaseTime DIV (Tempo * TmpNoteLen);
IF Freq > 0 THEN
Sound(1193180 DIV Freq);
Delay(SoundLen * Time);
IF Freq > 0 THEN
NoSound;
Delay((8 - SoundLen) * Time);
TmpNoteLen := 0;
BaseTime := 38000;
END;
{ ---- procs to handle music commands ------------------------------------- }
PROCEDURE DoLength (VAR Sounds: String);
BEGIN
GetNum(Sounds, Nr, Error);
IF NOT Error AND (Nr > 0) AND (Nr < 65) THEN
NoteLen := Nr;
END;
PROCEDURE DoMiscCmd (VAR Sounds: String);
BEGIN
IF Length(Sounds) > 0 THEN BEGIN
CASE Sounds[1] OF
'L': SoundLen := 8; { legato }
'N': SoundLen := 7; { normal }
'S': SoundLen := 6; { staccato }
ELSE ; { either MF (default) or MB (not supported) }
END;
Delete(Sounds, 1, 1);
END;
END;
PROCEDURE DoNoteLetter (VAR Sounds: String; Ch: Char);
VAR
SpecialLen, NotePos: Integer;
DotLen: LongInt;
NoteInfo: String;
BEGIN
NotePos := ORD(NoteConvert[ORD(Ch) - 64]) - 65;
IF Length(Sounds) > 0 THEN BEGIN
NoteInfo := '';
Ch := Sounds[1];
Delete(Sounds, 1, 1);
IF Ch = '-' THEN BEGIN
IF (NotePos IN [2, 4, 7, 9, 11]) THEN
DEC(NotePos);
IF (Length(Sounds) > 0) AND (Sounds[1] IN ['0'..'9', '.']) THEN BEGIN
Ch := Sounds[1];
Delete(Sounds, 1, 1);
END;
END ELSE IF ((Ch = '+') OR (Ch = '#')) THEN BEGIN
IF (NotePos IN [0, 2, 5, 7, 9]) THEN
INC(NotePos);
IF (Length(Sounds) > 0) AND (Sounds[1] IN ['0'..'9', '.']) THEN BEGIN
Ch := Sounds[1];
Delete(Sounds, 1, 1);
END;
END
ELSE IF NOT(Ch IN ['0'..'9', '.']) THEN
Sounds := Ch + Sounds;
IF (Ch IN ['0'..'9', '.']) THEN BEGIN
NoteInfo := NoteInfo + Ch;
WHILE (Length(Sounds) > 0) AND (Sounds[1] IN ['0'..'9', '.']) DO BEGIN
NoteInfo := NoteInfo + Sounds[1];
Delete(Sounds, 1, 1);
END;
IF TmpNoteLen = 0 THEN
TmpNoteLen := NoteLen;
DotLen := BaseTime;
WHILE Pos('.', NoteInfo) > 0 DO BEGIN
DotLen := DotLen SHR 1;
BaseTime := BaseTime + DotLen;
Delete(NoteInfo, Pos('.', NoteInfo), 1);
END;
IF (Length(NoteInfo) > 0) AND (Length(NoteInfo) < 3) THEN BEGIN
SpecialLen := WVal(NoteInfo);
IF (SpecialLen > 0) AND (SpecialLen < 65) THEN
TmpNoteLen := SpecialLen;
END;
END;
END;
PlayNote(BaseOctave[NotePos] SHR Octave);
END;
PROCEDURE DoNoteNumber (VAR Sounds: String);
BEGIN
GetNum(Sounds, Nr, Error);
IF NOT Error AND (Nr >= 0) AND (Nr <= 84) THEN
IF Nr = 0 THEN
PlayNote(Nr)
ELSE BEGIN
DEC(Nr);
PlayNote(BaseOctave[Nr MOD 12] SHR (Nr DIV 12));
END;
END;
PROCEDURE DoOctave (VAR Sounds: String);
BEGIN
GetNum(Sounds, Nr, Error);
IF NOT Error AND (Nr >= 0) AND (Nr <= 6) THEN
Octave := Nr;
END;
PROCEDURE DoPause (VAR Sounds: String);
BEGIN
GetNum(Sounds, Nr, Error);
IF NOT Error AND (Nr > 0) AND (Nr < 65) THEN BEGIN
TmpNoteLen := Nr;
PlayNote(0);
END;
END;
PROCEDURE DoTempo (VAR Sounds: String);
BEGIN
GetNum(Sounds, Nr, Error);
IF NOT Error AND (Nr >= 32) AND (Nr <= 255) THEN
Tempo := Nr;
END;
{ ---- public procs ------------------------------------------------------- }
{ play music in the foreground }
PROCEDURE PlayMF (Sounds: String);
VAR
Posn: Integer;
Ch: Char;
BEGIN
REPEAT { remove spaces }
Posn := Pos(' ', Sounds);
IF Posn > 0 THEN
Delete(Sounds, Posn, 1);
UNTIL Posn = 0;
Sounds := UpperCase(Sounds); { convert to uppercase }
WHILE (Length(Sounds) > 0) DO BEGIN { process music commands }
Ch := Sounds[1];
Delete(Sounds, 1, 1);
CASE Ch OF
'<': IF Octave > 1 THEN Dec(Octave);
'>': IF Octave < 6 THEN Inc(Octave);
'A'..'G': DoNoteLetter(Sounds, Ch);
'L': DoLength(Sounds);
'M': DoMiscCmd(Sounds);
'N': DoNoteNumber(Sounds);
'O': DoOctave(Sounds);
'P': DoPause(Sounds);
'T': DoTempo(Sounds);
END;
END;
END;
{ reset defaults to original values }
PROCEDURE ResetMF;
BEGIN
TmpNoteLen := 0;
BaseTime := 38000;
Octave := 4;
NoteLen := 4;
Tempo := 120;
SoundLen := 7;
END;
{ ----------------------- initialization code --------------------------- }
BEGIN
BaseOctave[0] := 18357; { C }
BaseOctave[1] := 17292; { C# or D- }
BaseOctave[2] := 16124; { D }
BaseOctave[3] := 15297; { D# or E- }
BaseOctave[4] := 14551; { E }
BaseOctave[5] := 13715; { F }
BaseOctave[6] := 12830; { F# or G- }
BaseOctave[7] := 12175; { G }
BaseOctave[8] := 11473; { G# }
BaseOctave[9] := 10847; { A }
BaseOctave[10] := 10286; { A# or B- }
BaseOctave[11] := 9623; { B }
NoteConvert := 'JLACEFH';
ResetMF;
END.